VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Crypt"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (hProv As Long, ByVal Container As String, ByVal Provider As String, ByVal ProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptSetProvider Lib "advapi32.dll" Alias "CryptSetProviderA" (ByVal Provider As String, ByVal ProvType As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, hHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, data As Byte, ByVal datalen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDeriveKey Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hHash As Long, ByVal dwFlags As Long, hKey As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetLastError Lib "kernel32.dll" () As Long
Private Declare Function CryptEncrypt Lib "advapi32.dll" (ByVal hKey As Long, ByVal hHash As Long, ByVal Final As Boolean, ByVal dwFlags As Long, data As Byte, datalen As Long, ByVal BuffLen As Long) As Long
Private Declare Function CryptDecrypt Lib "advapi32.dll" (ByVal hKey As Long, ByVal hHash As Long, ByVal Final As Boolean, ByVal dwFlags As Long, data As Byte, datalen As Long) As Long


Private hProv As Long
Private result As Long
Private hKey As Long
Private mPass As String
Private data() As Byte

Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"
Const PROV_RSA_FULL As Long = 1&
Const CALG_MD5 As Long = &H8003&
Const CALG_RC2 As Long = &H6602&
Const CRYPT_EXPORTABLE As Long = 1&
Const CRYPT_NEWKEYSET As Long = 8&
Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
Const CRYPT_DELETEKEYSET As Long = &H10&





Private Sub Class_Initialize()
 'Try to aquire a handle to the default provider
 result = CryptAcquireContext(hProv, vbNullString, MS_DEF_PROV, PROV_RSA_FULL, 0&)
 If hProv = 0 Then
 'Set the default if needed
 result = CryptSetProvider(MS_DEF_PROV, PROV_RSA_FULL)
APIok (result)
 'Get the handle again
 result = CryptAcquireContext(hProv, vbNullString, MS_DEF_PROV, PROV_RSA_FULL, 0&)
End If
'Check for key container
If result = 0 And hProv = 0 Then
 'make default key container
 result = CryptAcquireContext(hProv, vbNullString, MS_DEF_PROV, PROV_RSA_FULL, CRYPT_NEWKEYSET)
End If
'if it isn't ok now give up
APIok (result)
End Sub

Public Sub APIok(result As Long)
If result Then Exit Sub
Dim E As Long
E = GetLastError()
Err.Raise vbObjectError + E, "Crypto", "Crypto API error " + Str(E) + " has occured"
End
End Sub


Public Property Get PassWord() As Variant
PassWord = mPass
End Property

Public Property Let PassWord(ByVal vNewValue As Variant)
mPass = vNewValue
 'Create hash object
Dim hHash As Long
result = CryptCreateHash(hProv, CALG_MD5, 0&, 0&, hHash)
APIok (result)
'convert password string into an array of bytes
Dim datalen As Long
datalen = Len(mPass)
Dim data(100) As Byte
Call CopyStrToByte(mPass, data())
'hash the password
result = CryptHashData(hHash, data(0), datalen, 0)
APIok (result)
'delete any existing key
If (hKey <> 0) Then
 result = CryptDestroyKey(hKey)
End If
'Create session key using hash
    result = CryptDeriveKey(hProv, CALG_RC2, hHash, CRYPT_EXPORTABLE, hKey)
    APIok (result)
'Destroy hash object
    If (hHash <> 0) Then
     result = CryptDestroyHash(hHash)
    End If
End Property


Private Sub Class_Terminate()
If (hKey <> 0) Then
 result = CryptDestroyKey(hKey)
End If
If (hProv <> 0) Then
 result = CryptReleaseContext(hProv, 0)
End If
End Sub

Public Sub encrypt(Text As String, Final As Boolean)
Dim Count As Long
Count = Len(Text)
'set up buffer to be larger than string data
ReDim data(Count + 50) As Byte
'Copy text to buffer
  Call CopyStrToByte(Text, data())
'Encrypt text
  result = CryptEncrypt(hKey, 0&, Final, 0&, data(0), Count, Count + 50)
  APIok (result)
'convert buffer to string
 Call CopyByteToStr(data(), Count, Text)
End Sub

Public Sub decrypt(Text As String, Final As Boolean)
  Dim Count As Long
  Count = Len(Text)
  ReDim data(Count) As Byte
'Copy text to buffer
  Call CopyStrToByte(Text, data())
'Decode
result = CryptDecrypt(hKey, 0&, Final, 0&, data(0), Count)
'convert buffer to string
 Call CopyByteToStr(data(), Count, Text)
End Sub


Public Sub CopyStrToByte(a As String, b() As Byte)
 Dim i As Integer
If Len(a) > UBound(b, 1) Then APIok (0)
 For i = 1 To Len(a)
  b(i - 1) = Asc(Mid(a, i, 1))
 Next i
End Sub

Public Sub CopyByteToStr(b() As Byte, n As Long, a As String)
 Dim i As Integer
 a = ""
 For i = 1 To n
  a = a & Chr(b(i - 1))
 Next i
End Sub
